home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / pcl / pcl-rev4.lha / boot.lisp < prev    next >
Lisp/Scheme  |  1990-10-02  |  51KB  |  1,445 lines
  1. ;;;-*-Mode: LISP; Package:(PCL LISP 1000); Base:10; Syntax:Common-lisp -*-
  2. ;;;
  3. ;;; *************************************************************************
  4. ;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
  5. ;;; All rights reserved.
  6. ;;;
  7. ;;; Use and copying of this software and preparation of derivative works
  8. ;;; based upon this software are permitted.  Any distribution of this
  9. ;;; software or derivative works must comply with all applicable United
  10. ;;; States export control laws.
  11. ;;; 
  12. ;;; This software is made available AS IS, and Xerox Corporation makes no
  13. ;;; warranty about the software, its performance or its conformity to any
  14. ;;; specification.
  15. ;;; 
  16. ;;; Any person obtaining a copy of this software is requested to send their
  17. ;;; name and post office or electronic mail address to:
  18. ;;;   CommonLoops Coordinator
  19. ;;;   Xerox PARC
  20. ;;;   3333 Coyote Hill Rd.
  21. ;;;   Palo Alto, CA 94304
  22. ;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa)
  23. ;;;
  24. ;;; Suggestions, comments and requests for improvements are also welcome.
  25. ;;; *************************************************************************
  26. ;;;
  27.  
  28. (in-package 'pcl)
  29.  
  30. #|
  31.  
  32. The CommonLoops evaluator is meta-circular.  
  33.  
  34. Most of the code in PCL is methods on generic functions, including most of
  35. the code that actually implements generic functions and method lookup.
  36.  
  37. So, we have a classic bootstrapping problem.   The solution to this is to
  38. first get a cheap implementation of generic functions running, these are
  39. called early generic functions.  These early generic functions and the
  40. corresponding early methods and early method lookup are used to get enough
  41. of the system running that it is possible to create real generic functions
  42. and methods and implement real method lookup.  At that point (done in the
  43. file FIXUP) the function fix-early-generic-functions is called to convert
  44. all the early generic functions to real generic functions.
  45.  
  46. The cheap generic functions are built using the same funcallable-instance
  47. objects real generic-functions are made out of.  This means that as PCL
  48. is being bootstrapped, the cheap generic function objects which are being
  49. created are the same objects which will later be real generic functions.
  50. This is good because:
  51.   - we don't cons garbage structure
  52.   - we can keep pointers to the cheap generic function objects
  53.     during booting because those pointers will still point to
  54.     the right object after the generic functions are all fixed
  55.     up
  56.  
  57.  
  58.  
  59. This file defines the defmethod macro and the mechanism used to expand it.
  60. This includes the mechanism for processing the body of a method.  defmethod
  61. basically expands into a call to load-defmethod, which basically calls
  62. add-method to add the method to the generic-function.  These expansions can
  63. be loaded either during bootstrapping or when PCL is fully up and running.
  64.  
  65. An important effect of this structure is it means we can compile files with
  66. defmethod forms in them in a completely running PCL, but then load those files
  67. back in during bootstrapping.  This makes development easier.  It also means
  68. there is only one set of code for processing defmethod.  Bootstrapping works
  69. by being sure to have load-method be careful to call only primitives which
  70. work during bootstrapping.
  71.  
  72. |#
  73.  
  74. (proclaim '(notinline make-a-method
  75.               add-named-method              
  76.               ensure-generic-function-using-class
  77.  
  78.               add-method
  79.               remove-method
  80.               ))
  81.  
  82. (defvar *early-functions*
  83.     '((make-a-method early-make-a-method
  84.              real-make-a-method)
  85.       (add-named-method early-add-named-method
  86.                 real-add-named-method)
  87.       ))
  88.  
  89. ;;;
  90. ;;; For each of the early functions, arrange to have it point to its early
  91. ;;; definition.  Do this in a way that makes sure that if we redefine one
  92. ;;; of the early definitions the redefinition will take effect.  This makes
  93. ;;; development easier.
  94. ;;;
  95. ;;; The function which generates the redirection closure is pulled out into
  96. ;;; a separate piece of code because of a bug in ExCL which causes this not
  97. ;;; to work if it is inlined.
  98. ;;;
  99. (eval-when (load eval)
  100.  
  101.   (defun redirect-early-function-internal (to)
  102.     #'(lambda (&rest args) (apply (symbol-function to) args)))
  103.   
  104.   (dolist (fns *early-functions*)
  105.     (let ((name (car fns))
  106.       (early-name (cadr fns)))
  107.       (setf (symbol-function name)
  108.         (redirect-early-function-internal early-name))))
  109.  
  110.   )
  111.  
  112.  
  113. ;;;
  114. ;;; *generic-function-fixups* is used by fix-early-generic-functions to
  115. ;;; convert the few functions in the bootstrap which are supposed to be
  116. ;;; generic functions but can't be early on.
  117. ;;; 
  118. (defvar *generic-function-fixups*
  119.     '((add-method
  120.     ((generic-function method)                ;lambda-list
  121.      (standard-generic-function method)            ;specializers
  122.      real-add-method))                    ;method-function
  123.       (remove-method
  124.     ((generic-function method)
  125.      (standard-generic-function method)
  126.      real-remove-method))
  127.       (get-method
  128.         ((generic-function qualifiers specializers &optional (errorp t))
  129.      (standard-generic-function t t)
  130.      real-get-method))
  131.       (ensure-generic-function-using-class
  132.     ((generic-function function-specifier
  133.                &key generic-function-class environment
  134.                &allow-other-keys)
  135.      (generic-function t)
  136.      real-ensure-gf-using-class--generic-function)
  137.     ((generic-function function-specifier
  138.                &key generic-function-class environment
  139.                &allow-other-keys)
  140.      (null t)
  141.      real-ensure-gf-using-class--null))
  142.       ))
  143.  
  144.  
  145. ;;;
  146. ;;;
  147. ;;;
  148. (defmacro defgeneric (function-specifier lambda-list &body options)
  149.   (expand-defgeneric function-specifier lambda-list options))
  150.  
  151. (defun expand-defgeneric (function-specifier lambda-list options)
  152.   (when (listp function-specifier) (do-standard-defsetf-1 (cadr function-specifier)))
  153.   (let ((initargs ()))
  154.     (flet ((duplicate-option (name)
  155.          (error "The option ~S appears more than once." name)))
  156.       ;;
  157.       ;; INITARG takes this screwy new argument to get around a bad
  158.       ;; interaction between lexical macros and setf in the Lucid
  159.       ;; compiler.
  160.       ;; 
  161.       (macrolet ((initarg (key &optional new)
  162.            (if new
  163.                `(setf (getf initargs ,key) ,new)
  164.                `(getf initargs ,key))))
  165.     (dolist (option options)
  166.       (ecase (car option)
  167.         (:argument-precedence-order
  168.           (if (initarg :argument-precedence-order)
  169.           (duplicate-option :argument-precedence-order)
  170.           (initarg :argument-precedence-order `',(cdr option))))
  171.         (declare
  172.           (initarg :declarations
  173.                (append (cdr option) (initarg :declarations))))
  174.         (:documentation
  175.           (if (initarg :documentation)
  176.           (duplicate-option :documentation)
  177.           (initarg :documentation `',(cadr option))))
  178.         (:method-combination
  179.           (if (initarg :method-combination)
  180.           (duplicate-option :method-combination)
  181.           (initarg :method-combination `',(cdr option))))
  182.         (:generic-function-class
  183.           (if (initarg :generic-function-class)
  184.           (duplicate-option :generic-function-class)
  185.           (initarg :generic-function-class `',(cadr option))))
  186.         (:method-class
  187.           (if (initarg :method-class)
  188.           (duplicate-option :method-class)
  189.           (initarg :method-class `',(cadr option))))
  190.         (:method
  191.           (error
  192.         "DEFGENERIC doesn't support the :METHOD option yet."))))
  193.  
  194.     (let ((declarations (initarg :declarations)))
  195.       (when declarations (initarg :declarations `',declarations)))))
  196.  
  197.     (make-top-level-form `(defgeneric ,function-specifier)
  198.              *defgeneric-times*
  199.       `(load-defgeneric ',function-specifier ',lambda-list ,@initargs))))
  200.  
  201. (defun load-defgeneric (function-specifier lambda-list &rest initargs)
  202.   (when (listp function-specifier) (do-standard-defsetf-1 (cadr function-specifier)))
  203.   (apply #'ensure-generic-function
  204.      function-specifier
  205.      :lambda-list lambda-list
  206.      :definition-source `((defgeneric ,function-specifier)
  207.                   ,(load-truename))
  208.      initargs))
  209.  
  210.  
  211. ;;;
  212. ;;;
  213. ;;;
  214. (defmacro DEFMETHOD (&rest args &environment env)
  215.   #+(or (not :lucid) :lcl3.0)    
  216.   (declare (arglist name
  217.             {method-qualifier}*
  218.             specialized-lambda-list
  219.             &body body))
  220.   (multiple-value-bind (name qualifiers lambda-list body)
  221.       (parse-defmethod args)
  222.     (let ((proto-method (method-prototype-for-gf name)))
  223.       (expand-defmethod
  224.     proto-method name qualifiers lambda-list body env))))
  225.  
  226. ;;;
  227. ;;; takes a name which is either a generic function name or a list specifying
  228. ;;; a setf generic function (like: (SETF <generic-function-name>)).  Returns
  229. ;;; the prototype instance of the method-class for that generic function.
  230. ;;;
  231. ;;; If there is no generic function by that name, this returns the default
  232. ;;; value, the prototype instance of the class STANDARD-METHOD.  This default
  233. ;;; value is also returned if the spec names an ordinary function or even a
  234. ;;; macro.  In effect, this leaves the signalling of the appropriate error
  235. ;;; until load time.
  236. ;;;
  237. ;;; NOTE that during bootstrapping, this function is allowed to return NIL.
  238. ;;; 
  239. (defun method-prototype-for-gf (name)      
  240.   (let ((gf? (and (gboundp name)
  241.           (gdefinition name))))
  242.     (cond ((neq *boot-state* 'complete) nil)
  243.       ((or (null gf?)
  244.            (not (generic-function-p gf?)))            ;Someone else MIGHT
  245.                                 ;error at load time.
  246.        (class-prototype (find-class 'standard-method)))
  247.       (t
  248.         (class-prototype (or (generic-function-method-class gf?)
  249.                  (find-class 'standard-method)))))))
  250.  
  251.  
  252. #-Genera
  253. (defun expand-defmethod (proto-method name qualifiers lambda-list body env)
  254.   (when (listp name) (do-standard-defsetf-1 (cadr name)))
  255.   (multiple-value-bind (fn-form specializers doc plist)
  256.       (expand-defmethod-internal name qualifiers lambda-list body env)
  257.     (make-top-level-form `(defmethod ,name ,@qualifiers ,specializers)
  258.              *defmethod-times*
  259.       `(load-defmethod
  260.      ',(if proto-method
  261.            (class-name (class-of proto-method))
  262.            'standard-method)
  263.      ',name
  264.      ',qualifiers
  265.      (list ,@(mapcar #'(lambda (specializer)
  266.                  (if (and (consp specializer)
  267.                       (eq (car specializer) 'eql))
  268.                  ``(eql ,,(cadr specializer))
  269.                  `',specializer))
  270.              specializers))
  271.      ',(specialized-lambda-list-lambda-list lambda-list)
  272.      ',doc
  273.      ',(getf plist :isl-cache-symbol)    ;Paper over a bug in KCL by
  274.                         ;passing the cache-symbol
  275.                         ;here in addition to in the
  276.                         ;plist.
  277.      ',plist
  278.      ,fn-form))))
  279.  
  280. #+Genera
  281. (defun expand-defmethod (proto-method name qualifiers lambda-list body env)
  282.   (when (listp name) (do-standard-defsetf-1 (cadr name)))
  283.   (multiple-value-bind (fn-form specializers doc plist)
  284.       (expand-defmethod-internal name qualifiers lambda-list body env)
  285.     (let ((fn-args (cadadr fn-form))
  286.       (fn-body (cddadr fn-form))
  287.       (method-name `(method ,name ,@qualifiers ,specializers)))
  288.       `(progn
  289.      (proclaim '(function ,name))
  290.      (defun ,method-name ,fn-args
  291.        ,@fn-body)
  292.      (load-defmethod
  293.        ',(if proto-method
  294.          (class-name (class-of proto-method))
  295.          'standard-method)
  296.        ',name
  297.        ',qualifiers
  298.        (list ,@(mapcar #'(lambda (specializer)
  299.                    (if (and (consp specializer)
  300.                     (eq (car specializer) 'eql))
  301.                    ``(eql ,,(cadr specializer))
  302.                    `',specializer))
  303.                specializers))
  304.        ',(specialized-lambda-list-lambda-list lambda-list)
  305.        ',doc
  306.        ',(getf plist :isl-cache-symbol)    ;Paper over a bug in KCL by
  307.                         ;passing the cache-symbol
  308.                         ;here in addition to in the
  309.                         ;plist.
  310.        ',plist
  311.        #',method-name)))))
  312.  
  313. (defun expand-defmethod-internal
  314.        (generic-function-name qualifiers specialized-lambda-list body env)
  315.   (declare (values fn-form specializers doc)
  316.        (ignore qualifiers))
  317.   (when (listp generic-function-name)
  318.     (do-standard-defsetf-1 (cadr generic-function-name)))
  319.   (multiple-value-bind (documentation declarations real-body)
  320.       (extract-declarations body)
  321.     (multiple-value-bind (parameters lambda-list specializers)
  322.     (parse-specialized-lambda-list specialized-lambda-list)
  323.  
  324.       
  325.       (let* ((required-parameters
  326.            (mapcar #'(lambda (r s) (declare (ignore s)) r)
  327.                parameters
  328.                specializers))
  329.          (parameters-to-reference
  330.            (make-parameter-references specialized-lambda-list
  331.                       required-parameters
  332.                       declarations
  333.                       generic-function-name
  334.                       specializers))
  335.          (class-declarations 
  336.            `(declare
  337.           ,@(remove nil
  338.                 (mapcar #'(lambda (a s) (and (symbolp s)
  339.                              (neq s 't)
  340.                              `(class ,a ,s)))
  341.                     parameters
  342.                     specializers))))
  343.          (method-lambda 
  344.            ;; Remove the documentation string and insert the
  345.            ;; appropriate class declarations.  The documentation
  346.            ;; string is removed to make it easy for us to insert
  347.            ;; new declarations later, they will just go after the
  348.            ;; cadr of the method lambda.  The class declarations
  349.            ;; are inserted to communicate the class of the method's
  350.            ;; arguments to the code walk.
  351.            (let ()
  352.          `(lambda ,lambda-list
  353.             ,class-declarations
  354.             ,@declarations
  355.             (progn ,@parameters-to-reference)
  356.             (block ,(if (listp generic-function-name)
  357.                 (cadr generic-function-name)
  358.                 generic-function-name)
  359.               ,@real-body))))
  360.  
  361.          (call-next-method-p nil)   ;flag indicating that call-next-method
  362.                                     ;should be in the method definition
  363.          (closurep nil)        ;flag indicating that #'call-next-method
  364.                     ;was seen in the body of a method
  365.          (next-method-p-p nil)      ;flag indicating that next-method-p
  366.                                         ;should be in the method definition
  367.          (save-original-args nil)   ;flag indicating whether or not the
  368.                         ;original arguments to the method
  369.                     ;must be preserved.  This happens
  370.                     ;for two reasons:
  371.                                     ; - the method takes &mumble args,
  372.                     ;   so one of the lexical functions
  373.                     ;   might be used in a default value
  374.                                     ;   form
  375.                     ; - call-next-method is used without
  376.                     ;   arguments at least once in the
  377.                     ;   body of the method
  378.          (original-args ())
  379.          (applyp nil)        ;flag indicating whether or not the
  380.                     ;method takes &mumble arguments. If
  381.                     ;it does, it means call-next-method
  382.                     ;without arguments must be APPLY'd
  383.                     ;to original-args.  If this gets set
  384.                     ;true, save-original-args is set so
  385.                     ;as well
  386.          (aux-bindings ())        ;Suffice to say that &aux is one of
  387.                     ;damndest things to have put in a
  388.                     ;language.
  389.          (slots (mapcar #'list required-parameters))
  390.          (plist ())
  391.          (walked-lambda nil))
  392.     (flet ((walk-function (form context env)
  393.          (cond ((not (eq context ':eval)) form)
  394.                ((not (listp form)) form)
  395.                ((eq (car form) 'call-next-method)
  396.             (setq call-next-method-p 't)
  397.             (unless (cdr form)
  398.               (setq save-original-args t))
  399.             form)
  400.                ((eq (car form) 'next-method-p)
  401.             (setq next-method-p-p 't)
  402.             form)
  403.                ((and (eq (car form) 'function)
  404.                  (cond ((eq (cadr form) 'call-next-method)
  405.                     (setq call-next-method-p 't)
  406.                     (setq save-original-args 't)
  407.                     (setq closurep t)
  408.                     form)
  409.                    ((eq (cadr form) 'next-method-p)
  410.                     (setq next-method-p-p 't)
  411.                     (setq closurep t)
  412.                     form)
  413.                    (t nil))))
  414.                ((and (or (eq (car form) 'slot-value)
  415.                  (eq (car form) 'set-slot-value))
  416.                  (symbolp (cadr form))
  417.                  (constantp (caddr form)))
  418.             (let ((parameter
  419.                 (can-optimize-access (cadr form) required-parameters env)))
  420.               (if (null parameter)
  421.                   form
  422.                   (ecase (car form)
  423.                 (slot-value
  424.                   (optimize-slot-value     slots parameter form))
  425.                 (set-slot-value
  426.                   (optimize-set-slot-value slots parameter form))))))
  427.                (t form))))
  428.       
  429.       (setq walked-lambda (walk-form method-lambda env #'walk-function))
  430.  
  431.       ;;
  432.       ;; Add &allow-other-keys to the lambda list as an interim
  433.       ;; way of implementing lambda list congruence rules.
  434.       ;;
  435.       (when (and (memq '&key lambda-list)
  436.              (not (memq '&allow-other-keys lambda-list)))
  437.         (let* ((rll (reverse lambda-list))
  438.            (aux (memq '&aux rll)))
  439.           (setq lambda-list
  440.             (if aux
  441.             (progn (setf (cdr aux)
  442.                      (cons '&allow-other-keys (cdr aux)))
  443.                    (nreverse rll))
  444.                 (nconc (nreverse rll) (list '&allow-other-keys))))))
  445.       ;; Scan the lambda list to determine whether this method
  446.       ;; takes &mumble arguments.  If it does, we set applyp and
  447.       ;; save-original-args true.
  448.       ;; 
  449.       ;; This is also the place where we construct the original
  450.       ;; arguments lambda list if there has to be one.
  451.       (dolist (p lambda-list)
  452.         (if (memq p lambda-list-keywords)
  453.         (if (eq p '&aux)
  454.             (progn
  455.               (setq aux-bindings (cdr (memq '&aux lambda-list)))
  456.               (return nil))
  457.             (progn
  458.               (setq applyp t
  459.                 save-original-args t)
  460.               (push '&rest original-args)
  461.               (push (make-symbol "AMPERSAND-ARGS") original-args)
  462.               (return nil)))
  463.         (push (make-symbol (symbol-name p)) original-args)))
  464.       (setq original-args (if save-original-args
  465.                   (nreverse original-args)
  466.                   ()))
  467.       
  468.       (multiple-value-bind (ignore walked-declarations walked-lambda-body)
  469.           (extract-declarations (cddr walked-lambda))
  470.         (declare (ignore ignore))
  471.  
  472.         
  473.         (when (some #'cdr slots)
  474.           (setq slots (slot-name-lists-from-slots slots))
  475.           (setq plist (list* :isl slots plist))
  476.           (setq walked-lambda-body (add-pv-binding walked-lambda-body
  477.                                plist
  478.                                required-parameters)))
  479.         (when (or next-method-p-p call-next-method-p)
  480.           (setq plist (list* :needs-next-methods-p 't plist)))
  481.  
  482.         ;;; changes are here... (mt)
  483.         (let ((fn-body (if (or call-next-method-p next-method-p-p)
  484.                   (add-lexical-functions-to-method-lambda
  485.                 walked-declarations
  486.                 walked-lambda-body
  487.                 `(lambda ,lambda-list
  488.                    ,@walked-declarations
  489.                    ,.walked-lambda-body)
  490.                 original-args
  491.                 lambda-list
  492.                 save-original-args
  493.                 applyp
  494.                 aux-bindings
  495.                 call-next-method-p
  496.                 next-method-p-p
  497.                 closurep)
  498.                   `(lambda ,lambda-list
  499.                  ,@walked-declarations
  500.                  ,.walked-lambda-body))))
  501.           (values
  502.         `(function ,fn-body)
  503.         specializers
  504.         documentation
  505.         plist))))))))
  506.  
  507. (defun add-lexical-functions-to-method-lambda (walked-declarations
  508.                            walked-lambda-body
  509.                            walked-lambda
  510.                            original-args
  511.                            lambda-list
  512.                            save-original-args
  513.                            applyp
  514.                            aux-bindings
  515.                            call-next-method-p
  516.                            next-method-p-p
  517.                            closurep)
  518.   (cond ((and (null closurep)
  519.           (null applyp)
  520.           (null save-original-args))
  521.      ;; OK to use MACROLET, CALL-NEXT-METHOD is always passed some args, and
  522.      ;; all args are mandatory (else APPLYP would be true).
  523.      `(lambda ,lambda-list
  524.         ,@walked-declarations
  525.         (let ((.next-method. (car *next-methods*))
  526.           (.next-methods. (cdr *next-methods*)))
  527.           (macrolet ((call-next-method ,lambda-list
  528.                '(if .next-method.
  529.                 (let ((*next-methods* .next-methods.))
  530.                   (funcall .next-method. ,@lambda-list))
  531.                 (error "No next method.")))
  532.              (next-method-p () `(not (null .next-method.))))
  533.         ,@walked-lambda-body))))
  534.     ((and (null closurep)
  535.           (null applyp)
  536.           save-original-args)
  537.      ;; OK to use MACROLET.  CALL-NEXT-METHOD is sometimes called in the
  538.      ;; body with zero args, so we have to save the original args.
  539.      (if save-original-args
  540.          ;; CALL-NEXT-METHOD is sometimes called with no args
  541.          `(lambda ,original-args
  542.         (let ((.next-method. (car *next-methods*))
  543.               (.next-methods. (cdr *next-methods*)))
  544.           (macrolet ((call-next-method (&rest cnm-args)
  545.                    `(if .next-method.
  546.                     (let ((*next-methods* .next-methods.))
  547.                       (funcall .next-method.
  548.                            ,@(if cnm-args cnm-args ',original-args)))
  549.                     (error "No next method.")))
  550.                  (next-method-p () `(not (null .next-method.))))
  551.             (let* (,@(mapcar #'list lambda-list original-args)
  552.                  ,@aux-bindings)
  553.               ,@walked-declarations
  554.               ,@walked-lambda-body))))))
  555.     ((and (null save-original-args)
  556.           (null applyp))
  557.      ;;
  558.      ;; We don't have to save the original arguments.  In addition,
  559.      ;; this method doesn't take any &mumble arguments (this means
  560.      ;; that there is no way the lexical functions can be used inside
  561.      ;; of the default value form for an &mumble argument).
  562.      ;;
  563.      ;; We can expand this into a simple lambda expression with an
  564.      ;; FLET to define the lexical functions.
  565.      ;; 
  566.      `(lambda ,lambda-list
  567.         ,@walked-declarations
  568.         (let ((.next-method. (car *next-methods*))
  569.           (.next-methods. (cdr *next-methods*)))
  570.           (flet (,@(and call-next-method-p
  571.                 '((call-next-method (&rest cnm-args)
  572.                 #+Genera
  573.                 (declare (dbg:invisible-frame :clos-internal))
  574.                 (if .next-method.
  575.                     (let ((*next-methods* .next-methods.))
  576.                       (apply .next-method. cnm-args))
  577.                     (error "No next method.")))))
  578.              ,@(and next-method-p-p
  579.                 '((next-method-p ()
  580.                 (not (null .next-method.))))))
  581.         ,@walked-lambda-body))))
  582.     ((null applyp)
  583.      ;;
  584.      ;; This method doesn't accept any &mumble arguments.  But we
  585.      ;; do have to save the original arguments (this is because
  586.      ;; call-next-method is being called with no arguments).
  587.      ;; Have to be careful though, there may be multiple calls to
  588.      ;; call-next-method, all we know is that at least one of them
  589.      ;; is with no arguments.
  590.      ;; 
  591.      `(lambda ,original-args
  592.         (let ((.next-method. (car *next-methods*))
  593.           (.next-methods. (cdr *next-methods*)))
  594.           (flet (,@(and call-next-method-p
  595.                             `((call-next-method (&rest cnm-args)
  596.                 (if .next-method.
  597.                     (let ((*next-methods* .next-methods.))
  598.                       (if cnm-args
  599.                       (apply .next-method. cnm-args)
  600.                       (funcall .next-method.
  601.                            ,@original-args)))
  602.                     (error "No next method.")))))
  603.              ,@(and next-method-p-p
  604.                 '((next-method-p ()
  605.                 (not (null .next-method.))))))
  606.         (let* (,@(mapcar #'list
  607.                  (remtail lambda-list (memq '&aux lambda-list))
  608.                  original-args)
  609.                ,@aux-bindings)
  610.           ,@walked-declarations
  611.           ,@walked-lambda-body)))))
  612.     (t
  613.      ;;
  614.      ;; This is the fully general case.
  615.      ;; We must allow for the lexical functions being used inside
  616.      ;; the default value forms of &mumble arguments, and if must
  617.      ;; allow for call-next-method being called with no arguments.
  618.      ;; 
  619.      `(lambda ,original-args
  620.         (let ((.next-method. (car *next-methods*))
  621.           (.next-methods. (cdr *next-methods*)))
  622.           (flet (,@(and call-next-method-p
  623.                 `((call-next-method (&rest cnm-args)
  624.                 (if .next-method.
  625.                     (let ((*next-methods* .next-methods.))
  626.                       (if cnm-args
  627.                       (apply .next-method. cnm-args)
  628.                       (apply .next-method. 
  629.                          ,@(remove '&rest
  630.                                original-args))))
  631.                     (error "No next method.")))))
  632.              ,@(and next-method-p-p
  633.                 '((next-method-p ()
  634.                 (not (null .next-method.))))))
  635.         (apply (function ,walked-lambda)
  636.                ,@(remove '&rest original-args))))))))
  637.  
  638.  
  639. (defun make-parameter-references (specialized-lambda-list
  640.                   required-parameters
  641.                   declarations
  642.                   generic-function-name
  643.                   specializers)
  644.   (flet ((ignoredp (symbol)
  645.        (dolist (decl (cdar declarations))
  646.          (when (and (eq (car decl) 'ignore)
  647.             (memq symbol (cdr decl)))
  648.            (return t)))))       
  649.     (gathering ((references (collecting)))
  650.       (iterate ((s (list-elements specialized-lambda-list))
  651.         (p (list-elements required-parameters)))
  652.     (progn p)
  653.     (cond ((not (listp s)))
  654.           ((ignoredp (car s))
  655.            (warn "In defmethod ~S ~S, there is a~%~
  656.                       redundant ignore declaration for the parameter ~S."
  657.              generic-function-name
  658.              specializers
  659.              (car s)))
  660.           (t
  661.            (gather (car s) references)))))))
  662.  
  663.  
  664. (defvar *method-function-plist* (make-hash-table :test #'eq))
  665.  
  666. (defun method-function-plist (method-function)
  667.   (gethash method-function *method-function-plist*))
  668.  
  669. (defun SETF\ PCL\ METHOD-FUNCTION-PLIST (val method-function)
  670.   (setf (gethash method-function *method-function-plist*) val))
  671.  
  672. (defun method-function-get (method-function key)
  673.   (getf (method-function-plist method-function) key))
  674.  
  675. (defun SETF\ PCL\ METHOD-FUNCTION-GET (val method-function key)
  676.   (setf (getf  (method-function-plist method-function) key) val))
  677.  
  678.  
  679. (defun method-function-isl (method-function)
  680.   (method-function-get method-function :isl))
  681.  
  682. (defun method-function-needs-next-methods-p (method-function)
  683.   (method-function-get method-function :needs-next-methods-p))
  684.  
  685.  
  686.  
  687.  
  688. (defun load-defmethod
  689.        (class name quals specls ll doc isl-cache-symbol plist fn)
  690.   (when (listp name) (do-standard-defsetf-1 (cadr name)))
  691.   (let ((method-spec (make-method-spec name quals specls)))
  692.     (record-definition 'method method-spec)
  693.     (setq fn (set-function-name fn method-spec))
  694.     (load-defmethod-internal
  695.       name quals specls ll doc isl-cache-symbol plist fn class)))
  696.  
  697. (defun load-defmethod-internal
  698.        (gf-spec qualifiers specializers
  699.     lambda-list doc isl-cache-symbol plist fn method-class)
  700.   (when (listp gf-spec) (do-standard-defsetf-1 (cadr gf-spec)))
  701.   (when plist
  702.     (setq plist (copy-list plist))         ;Do this to keep from affecting
  703.                          ;the plist that is about to be
  704.                          ;dumped when we are compiling.
  705.     (let ((uisl (getf plist :isl))
  706.       (isl nil))
  707.       (when uisl
  708.     (setq isl (intern-slot-name-lists uisl))
  709.     (setf (getf plist :isl) isl))
  710.       (when isl-cache-symbol
  711.     (setf (getf plist :isl-cache-symbol) isl-cache-symbol)
  712.     (set isl-cache-symbol isl)))
  713.     
  714.     (setf (method-function-plist fn) plist))
  715.   (let ((method (add-named-method
  716.           gf-spec qualifiers specializers lambda-list fn
  717.           :documentation doc
  718.           :definition-source `((defmethod ,gf-spec
  719.                           ,@qualifiers
  720.                           ,specializers)
  721.                        ,(load-truename)))))
  722.     (unless (or (eq method-class 'standard-method)
  723.         (eq (find-class method-class nil) (class-of method)))
  724.       (format *error-output*
  725.           "At the time the method with qualifiers ~:~S and~%~
  726.                specializers ~:S on the generic function ~S~%~
  727.                was compiled, the method-class for that generic function was~%~
  728.                ~S.  But, the method class is now ~S, this~%~
  729.                may mean that this method was compiled improperly."
  730.           qualifiers specializers gf-spec
  731.           method-class (class-name (class-of method))))
  732.     method))
  733.  
  734.  
  735. (defun make-method-spec (gf-spec qualifiers unparsed-specializers)
  736.   `(method ,gf-spec ,@qualifiers ,unparsed-specializers))
  737.  
  738.  
  739.  
  740. ;;;; Early generic-function support
  741. ;;;
  742. ;;;
  743. (defvar *early-generic-functions* ())
  744.  
  745. (defun ensure-generic-function (function-specifier
  746.                 &rest all-keys
  747.                 &key environment
  748.                 &allow-other-keys)
  749.   (declare (ignore environment))
  750.   (let ((existing (and (gboundp function-specifier)               
  751.                (gdefinition function-specifier))))
  752.     (if (and existing
  753.          (eq *boot-state* 'complete)
  754.          (null (generic-function-p existing)))
  755.     (generic-clobbers-function function-specifier)
  756.     (apply #'ensure-generic-function-using-class existing function-specifier all-keys))))
  757.  
  758. (defun generic-clobbers-function (function-specifier)
  759.   #+Lispm (zl:signal 'generic-clobbers-function :name function-specifier)
  760.   #-Lispm (error "~S already names an ordinary function or a macro,~%~
  761.                   you may want to replace it with a generic function, but doing so~%~
  762.                   will require that you decide what to do with the existing function~%~
  763.                   definition.~%~
  764.                   The PCL-specific function MAKE-SPECIALIZABLE may be useful to you."
  765.          function-specifier))
  766.  
  767. #+Lispm
  768. (zl:defflavor generic-clobbers-function (name) (si:error)
  769.   :initable-instance-variables)
  770.  
  771. #+Lispm
  772. (zl:defmethod #+Genera (dbg:report generic-clobbers-function)
  773.           #+ti (generic-clobbers-function :report)
  774.           (stream)
  775.  (format stream
  776.      "~S aready names a ~a"
  777.      name
  778.      (if (and (symbolp name) (macro-function name)) "macro" "function")))
  779.  
  780. #+Genera
  781. (zl:defmethod (sys:proceed generic-clobbers-function :specialize-it) ()
  782.   "Make it specializable anyway?"
  783.   (make-specializable name))
  784.  
  785. #+ti
  786. (zl:defmethod
  787.      (generic-clobbers-function :case :proceed-asking-user :specialize-it)
  788.      (continuation ignore)
  789.   "Make it specializable anyway?"
  790.   (make-specializable name)
  791.   (funcall continuation :specialize-it))
  792.  
  793. ;;;
  794. ;;; This is the early definition of ensure-generic-function-using-class.
  795. ;;; 
  796. ;;; The static-slots field of the funcallable instances used as early generic
  797. ;;; functions is used to store the early methods and early discriminator code
  798. ;;; for the early generic function.  The static slots field of the fins
  799. ;;; contains a list whose:
  800. ;;;    CAR    -   a list of the early methods on this early gf
  801. ;;;    CADR   -   the early discriminator code for this method
  802. ;;;    
  803. (defun ensure-generic-function-using-class (existing spec &rest keys)
  804.   (declare (ignore keys))
  805.   (if* existing
  806.        existing
  807.        (pushnew spec *early-generic-functions* :test #'equal)
  808.        (let ((fin (allocate-funcallable-instance-1)))
  809.      (setf (gdefinition spec) fin)
  810.      (setf (fsc-instance-slots fin) (list nil nil))
  811.      fin)))
  812.  
  813. (defun early-gf-p (x)
  814.   (and (fsc-instance-p x)
  815.        (listp (fsc-instance-slots x))))
  816.  
  817. (defmacro early-gf-methods (early-gf)        ;These are macros so that
  818.   `(car (fsc-instance-slots ,early-gf)))    ;they can be setf'd.
  819.                         ;
  820. (defmacro early-gf-discriminator-code (early-gf);
  821.   `(cadr (fsc-instance-slots ,early-gf)))    ;
  822.  
  823.  
  824. (defmacro real-ensure-gf-internal (gf-class all-keys env)
  825.   `(progn
  826.      (cond ((symbolp ,gf-class)
  827.         (setq ,gf-class (find-class ,gf-class t ,env)))
  828.        ((classp ,gf-class))
  829.        (t
  830.         (error "The :GENERIC-FUNCTION-CLASS argument (~S) was neither a~%~
  831.                     class nor a symbol that names a class."
  832.            ,gf-class)))
  833.      (remf ,all-keys :generic-function-class)
  834.      (remf ,all-keys :environment)
  835.      (let ((combin (getf ,all-keys :method-combination '.shes-not-there.)))
  836.        (unless (eq combin '.shes-not-there.)
  837.      (setf (getf ,all-keys :method-combination)
  838.            (find-method-combination (class-prototype ,gf-class)
  839.                     (car combin)
  840.                     (cdr combin)))))
  841.      ))
  842.      
  843. (defun real-ensure-gf-using-class--generic-function
  844.        (existing
  845.     function-specifier
  846.     &rest all-keys
  847.     &key environment
  848.          (generic-function-class 'standard-generic-function gf-class-p)
  849.     &allow-other-keys)
  850.   (declare (ignore function-specifier))
  851.   (real-ensure-gf-internal generic-function-class all-keys environment)
  852.   (unless (or (null gf-class-p)
  853.           (eq (class-of existing) generic-function-class))
  854.     (change-class existing generic-function-class))
  855.   (apply #'reinitialize-instance existing all-keys))
  856.  
  857. (defun real-ensure-gf-using-class--null
  858.        (existing
  859.     function-specifier
  860.     &rest all-keys
  861.     &key environment
  862.          (generic-function-class 'standard-generic-function)
  863.     &allow-other-keys)
  864.   (declare (ignore existing))
  865.   (real-ensure-gf-internal generic-function-class all-keys environment)
  866.   (setf (gdefinition function-specifier)
  867.     (apply #'make-instance generic-function-class :name function-specifier all-keys)))
  868.  
  869.  
  870.  
  871. (defun early-make-a-method (class qualifiers arglist specializers function doc
  872.                 &optional slot-name)
  873.   (let ((parsed ())
  874.     (unparsed ()))
  875.     ;; Figure out whether we got class objects or class names as the
  876.     ;; specializers and set parsed and unparsed appropriately.  If we
  877.     ;; got class objects, then we can compute unparsed, but if we got
  878.     ;; class names we don't try to compute parsed.
  879.     ;; 
  880.     ;; Note that the use of not symbolp in this call to every should be
  881.     ;; read as 'classp' we can't use classp itself because it doesn't
  882.     ;; exist yet.
  883.     (if (every #'(lambda (s) (not (symbolp s))) specializers)
  884.     (setq parsed specializers
  885.           unparsed (mapcar #'(lambda (s)
  886.                    (if (eq s 't) 't (class-name s)))
  887.                    specializers))
  888.     (setq unparsed specializers
  889.           parsed ()))
  890.     (list :early-method          ;This is an early method dammit!
  891.       
  892.       function                ;Function is here for the benefit
  893.                   ;of early-lookup-method.
  894.       
  895.       parsed                  ;The parsed specializers.  This is used
  896.                   ;by early-method-specializers to cache
  897.                   ;the parse.  Note that this only comes
  898.                   ;into play when there is more than one
  899.                   ;early method on an early gf.
  900.       
  901.       (list class             ;A list to which real-make-a-method
  902.         qualifiers        ;can be applied to make a real method
  903.         arglist           ;corresponding to this early one.
  904.         unparsed
  905.         function
  906.         doc
  907.         slot-name)
  908.       )))
  909.  
  910. (defun real-make-a-method
  911.        (class qualifiers lambda-list specializers function doc
  912.     &optional slot-name)
  913.   ;; Hmm what is this use of when buying me??
  914.   (when (some #'(lambda (x) (and (neq x 't) (symbolp x))) specializers)
  915.     (setq specializers (parse-specializers specializers)))
  916.   (make-instance class :qualifiers qualifiers
  917.                :lambda-list lambda-list
  918.                :specializers specializers
  919.                :function function
  920.                :documentation doc
  921.                :slot-name slot-name
  922.                :allow-other-keys t))
  923.  
  924. (defun early-method-function (early-method)
  925.   (cadr early-method))
  926.  
  927. ;;;
  928. ;;; Fetch the specializers of an early method.  This is basically just a
  929. ;;; simple accessor except that when the second argument is t, this converts
  930. ;;; the specializers from symbols into class objects.  The class objects
  931. ;;; are cached in the early method, this makes bootstrapping faster because
  932. ;;; the class objects only have to be computed once.
  933. ;;; NOTE:
  934. ;;;  the second argument should only be passed as T by early-lookup-method.
  935. ;;;  this is to implement the rule that only when there is more than one
  936. ;;;  early method on a generic function is the conversion from class names
  937. ;;;  to class objects done.
  938. ;;;  the corresponds to the fact that we are only allowed to have one method
  939. ;;;  on any generic function up until the time classes exist.
  940. ;;;  
  941. (defun early-method-specializers (early-method &optional objectsp)
  942.   (if (and (listp early-method)
  943.        (eq (car early-method) :early-method))
  944.       (cond ((eq objectsp 't)
  945.          (or (caddr early-method)
  946.          (setf (caddr early-method)
  947.                (mapcar #'find-class (cadddr (cadddr early-method))))))
  948.         (t
  949.          (cadddr (cadddr early-method))))
  950.       (error "~S is not an early-method." early-method)))
  951.  
  952. (defun early-method-qualifiers (early-method)
  953.   (cadr (cadddr early-method)))
  954.  
  955. (defun early-add-named-method (generic-function-name
  956.                    qualifiers
  957.                    specializers
  958.                    arglist
  959.                    function
  960.                    &rest options)
  961.   (declare (ignore options))
  962.   (let* ((gf (ensure-generic-function generic-function-name))
  963.      (existing
  964.        (dolist (m (early-gf-methods gf))
  965.          (when (and (equal (early-method-specializers m) specializers)
  966.             (equal (early-method-qualifiers m) qualifiers))
  967.            (return m))))
  968.      (new (make-a-method 'standard-method
  969.                  qualifiers
  970.                  arglist
  971.                  specializers
  972.                  function
  973.                  ())))
  974.     (when existing (remove-method gf existing))
  975.     (add-method gf new)))
  976.  
  977. ;;;
  978. ;;; This is the early version of add-method.  Later this will become a
  979. ;;; generic function.  See fix-early-generic-functions which has special
  980. ;;; knowledge about add-method.
  981. ;;;
  982. (defun add-method (generic-function method)
  983.   (when (not (fsc-instance-p generic-function))
  984.     (error "Early add-method didn't get a funcallable instance."))
  985.   (when (not (and (listp method) (eq (car method) :early-method)))
  986.     (error "Early add-method didn't get an early method."))
  987.   (push method (early-gf-methods generic-function))
  988.   (early-update-discriminator-code generic-function))
  989.  
  990. ;;;
  991. ;;; This is the early version of remove method.
  992. ;;;
  993. (defun remove-method (generic-function method)
  994.   (when (not (fsc-instance-p generic-function))
  995.     (error "Early remove-method didn't get a funcallable instance."))
  996.   (when (not (and (listp method) (eq (car method) :early-method)))
  997.     (error "Early remove-method didn't get an early method."))
  998.   (setf (early-gf-methods generic-function)
  999.     (remove method (early-gf-methods generic-function)))
  1000.   (early-update-discriminator-code generic-function))
  1001.  
  1002. ;;;
  1003. ;;; And the early version of get-method.
  1004. ;;;
  1005. (defun get-method (generic-function qualifiers specializers
  1006.                     &optional (errorp t))
  1007.   (if (early-gf-p generic-function)
  1008.       (or (dolist (m (early-gf-methods generic-function))
  1009.         (when (and (or (equal (early-method-specializers m nil)
  1010.                   specializers)
  1011.                (equal (early-method-specializers m 't)
  1012.                   specializers))
  1013.                (equal (early-method-qualifiers m) qualifiers))
  1014.           (return m)))
  1015.       (if errorp
  1016.           (error "Can't get early method.")
  1017.           nil))
  1018.       (real-get-method generic-function qualifiers specializers errorp)))
  1019.  
  1020. (defun early-update-discriminator-code (generic-function)
  1021.   (let* ((methods (early-gf-methods generic-function))
  1022.      (early-dfun
  1023.        (cond ((null methods)
  1024.           #'(lambda (&rest ignore)
  1025.               (declare (ignore ignore))
  1026.               (error "Called an early generic-function that ~
  1027.                               has no methods?")))
  1028.          ((null (cdr methods))
  1029.           ;; If there is only one method, just use that method's
  1030.           ;; function.  This corresponds to the important fact
  1031.           ;; that early generic-functions with only one method
  1032.           ;; always call that method when they are called.  If
  1033.           ;; there is more than one method, we have to install
  1034.           ;; a simple little discriminator-code for this generic
  1035.           ;; function.
  1036.           (cadr (car methods)))
  1037.          (t
  1038.           #'(lambda (&rest args) (early-dfun methods args))))))
  1039.     (set-funcallable-instance-function generic-function early-dfun)
  1040.     (setf (early-gf-discriminator-code generic-function) early-dfun)))
  1041.  
  1042. (defun early-get-cpl (object)
  1043.   (bootstrap-get-slot 'std-class        ;HMMM? should be PCL-CLASS
  1044.               (class-of object)
  1045.               'class-precedence-list))
  1046.  
  1047. (defun early-sort-methods (list args)
  1048.   (if (null (cdr list))
  1049.       list
  1050.       (sort list
  1051.         #'(lambda (specls-1 specls-2)
  1052.         (iterate ((s1 (list-elements specls-1))
  1053.               (s2 (list-elements specls-2))
  1054.               (a (list-elements args)))
  1055.           (cond ((eq s1 s2))
  1056.             ((eq s2 *the-class-t*) (return t))
  1057.             ((eq s1 *the-class-t*) (return nil))
  1058.             (t (return (memq s2 (memq s1 (early-get-cpl a))))))))
  1059.         :key #'(lambda (em) (early-method-specializers em t)))))
  1060.  
  1061. (defun early-dfun (methods args)
  1062.   (let ((primary ())
  1063.     (before ())
  1064.     (after ())
  1065.     (around ()))
  1066.     (dolist (method methods)
  1067.       (let* ((specializers (early-method-specializers method t))
  1068.          (qualifiers (early-method-qualifiers method))
  1069.          (args args)
  1070.          (specs specializers))
  1071.     (when (loop
  1072.         (when (or (null args)
  1073.               (null specs))
  1074.           ;; If we are out of specs, then we must be in the optional,
  1075.           ;; rest or keywords arguments.  This method is applicable
  1076.           ;; to these arguments.  Return T.
  1077.           (return t))
  1078.         (let ((arg (pop args))
  1079.               (spec (pop specs)))
  1080.           (unless (or (eq spec *the-class-t*)
  1081.                   (memq spec (early-get-cpl arg)))
  1082.             (return nil))))
  1083.       (cond ((null qualifiers) (push method primary))
  1084.         ((equal qualifiers '(:before)) (push method before))
  1085.         ((equal qualifiers '(:after))  (push method after))
  1086.         ((equal qualifiers '(:around)) (push method around))
  1087.         (t
  1088.          (error "Unrecognized qualifer in early method."))))))
  1089.     (setq primary (early-sort-methods primary args)
  1090.       before  (early-sort-methods before  args)
  1091.       after   (early-sort-methods after   args)
  1092.       around  (early-sort-methods around  args))
  1093.     (flet ((do-main-combined-method (arguments)
  1094.          (dolist (m before) (apply (cadr m) arguments))
  1095.          (multiple-value-prog1
  1096.            (let ((*next-methods* (mapcar #'car (cdr primary))))
  1097.          (apply (cadar primary) arguments))
  1098.            (dolist (m after) (apply (cadr m) arguments)))))
  1099.       (if (null around)
  1100.       (do-main-combined-method args)
  1101.       (let ((*next-methods*
  1102.           (append (mapcar #'cadr (cdr around))
  1103.               #'do-main-combined-method)))
  1104.         (apply (caar around) args))))))
  1105.  
  1106. (defun fix-early-generic-functions (&optional noisyp)
  1107.   (allocate-instance (find-class 'standard-generic-function));Be sure this
  1108.                                      ;class has an
  1109.                                      ;instance.
  1110.   (let* ((class (find-class 'standard-generic-function))
  1111.      (wrapper (class-wrapper class))
  1112.      (n-static-slots (class-no-of-instance-slots class))
  1113.      (default-initargs (default-initargs class ()))
  1114.      #+Lucid
  1115.      (lucid::*redefinition-action* nil)
  1116.      (*invalidate-discriminating-function-force-p* t))
  1117.     (flet ((fix-structure (gf)
  1118.          (let ((static-slots
  1119.              (%allocate-static-slot-storage--class n-static-slots)))
  1120.            (setf (fsc-instance-wrapper gf) wrapper
  1121.              (fsc-instance-slots gf) static-slots))))
  1122.  
  1123.       (dolist (early-gf-spec *early-generic-functions*)
  1124.     (when noisyp (format t "~&~S..." early-gf-spec))
  1125.     (let* ((early-gf (gdefinition early-gf-spec))
  1126.            (early-static-slots
  1127.          (fsc-instance-slots early-gf))
  1128.            (early-discriminator-code nil)
  1129.            (early-methods nil)
  1130.            (methods ())
  1131.            (aborted t))
  1132.       (flet ((trampoline (&rest args)
  1133.            (apply early-discriminator-code args)))
  1134.         (if (not (listp early-static-slots))
  1135.         (when noisyp (format t "already fixed?"))
  1136.         (unwind-protect
  1137.             (progn
  1138.               (setq early-discriminator-code
  1139.                 (early-gf-discriminator-code early-gf))
  1140.               (setq early-methods
  1141.                 (early-gf-methods early-gf))
  1142.               (setf (gdefinition early-gf-spec) #'trampoline)
  1143.               (when noisyp (format t "trampoline..."))
  1144.               (fix-structure early-gf)
  1145.               (when noisyp (format t "fixed..."))
  1146.               (apply #'initialize-instance early-gf
  1147.                  :name early-gf-spec default-initargs)
  1148.               (dolist (early-method early-methods)
  1149.             (destructuring-bind
  1150.                  (class quals lambda-list specs fn doc slot-name)
  1151.                  (cadddr early-method)
  1152.               (setq specs
  1153.                 (early-method-specializers early-method t))
  1154.               (let ((method (real-make-a-method class
  1155.                                 quals
  1156.                                 lambda-list
  1157.                                 specs
  1158.                                 fn
  1159.                                 doc
  1160.                                 slot-name)))
  1161.                 (real-add-method early-gf method)
  1162.                 (push method methods)
  1163.                 (when noisyp (format t "m")))))
  1164.               (setf (slot-value early-gf 'name) early-gf-spec)
  1165.               (fixup-magic-generic-function early-gf-spec
  1166.                             early-methods
  1167.                             early-gf
  1168.                             (reverse methods))
  1169.               (setq aborted nil))
  1170.           (setf (gdefinition early-gf-spec) early-gf)
  1171.           (when noisyp (format t "."))
  1172.           (when aborted
  1173.             (setf (fsc-instance-slots early-gf)
  1174.               early-static-slots)))))))
  1175.       
  1176.       (dolist (fns *early-functions*)
  1177.     (setf (symbol-function (car fns)) (symbol-function (caddr fns))))
  1178.       
  1179.       (dolist (fixup *generic-function-fixups*)
  1180.     (let ((fspec (car fixup))
  1181.           (methods (cdr fixup))
  1182.           (gf (make-instance 'standard-generic-function)))
  1183.       (set-function-name gf fspec)
  1184.       (setf (generic-function-name gf) fspec)
  1185.       (dolist (method methods)
  1186.         (destructuring-bind (lambda-list specializers method-fn-name)
  1187.                 method
  1188.           (let* ((fn (if method-fn-name
  1189.                  (symbol-function method-fn-name)
  1190.                  (symbol-function fspec)))
  1191.              (method (make-a-method 'standard-method
  1192.                         ()
  1193.                         lambda-list
  1194.                         specializers
  1195.                         fn
  1196.                         nil)))
  1197.         (real-add-method gf method))))
  1198.       (setf (gdefinition fspec) gf))))))
  1199.  
  1200.  
  1201. ;;;
  1202. ;;; parse-defmethod is used by defmethod to parse the &rest argument into
  1203. ;;; the 'real' arguments.  This is where the syntax of defmethod is really
  1204. ;;; implemented.
  1205. ;;; 
  1206. (defun parse-defmethod (cdr-of-form)
  1207.   (declare (values name qualifiers specialized-lambda-list body))
  1208.   (let ((name (pop cdr-of-form))
  1209.     (qualifiers ())
  1210.     (spec-ll ()))
  1211.     (loop (if (and (car cdr-of-form) (atom (car cdr-of-form)))
  1212.           (push (pop cdr-of-form) qualifiers)
  1213.           (return (setq qualifiers (nreverse qualifiers)))))
  1214.     (setq spec-ll (pop cdr-of-form))
  1215.     (values name qualifiers spec-ll cdr-of-form)))
  1216.  
  1217. (defun parse-specializers (specializers)
  1218.   (flet ((parse (spec)
  1219.        (cond ((symbolp spec)
  1220.           (or (find-class spec nil)
  1221.               (error
  1222.             "~S used as a specializer,~%~
  1223.                          but is not the name of a class."
  1224.             spec)))
  1225.          ((and (listp spec)
  1226.                (eq (car spec) 'eql)
  1227.                (null (cddr spec)))
  1228.           (make-instance 'eql-specializer :object (cadr spec))    ;*EQL*
  1229. ;          spec
  1230.           )
  1231.          (t (error "~S is not a legal specializer." spec)))))
  1232.     (mapcar #'parse specializers)))
  1233.  
  1234. (defun unparse-specializers (specializers-or-method)
  1235.   (if (listp specializers-or-method)
  1236.       (flet ((unparse (spec)
  1237.            (cond ((classp spec)
  1238.               (or (class-name spec) spec))
  1239.              ((eql-specializer-p spec)       ;*EQL*
  1240.               (eql-specializer-object spec)
  1241. ;              (and (listp spec) (eq (car spec) 'eql))
  1242. ;              spec
  1243.               )
  1244.              (t
  1245.               (error "~S is not a legal specializer." spec)))))
  1246.     (mapcar #'unparse specializers-or-method))
  1247.       (unparse-specializers (method-specializers specializers-or-method))))
  1248.  
  1249.  
  1250.  
  1251. (defun parse-method-or-spec (spec &optional (errorp t))
  1252.   (declare (values generic-function method method-name))
  1253.   (let (gf method name temp)
  1254.     (if (method-p spec)    
  1255.     (setq method spec
  1256.           gf (method-generic-function method)
  1257.           temp (and gf (generic-function-name gf))
  1258.           name (if temp
  1259.                (intern-function-name
  1260.              (make-method-spec temp
  1261.                        (method-qualifiers method)
  1262.                        (unparse-specializers
  1263.                          (method-specializers method))))
  1264.                (make-symbol (format nil "~S" method))))
  1265.     (multiple-value-bind (gf-spec quals specls)
  1266.         (parse-defmethod spec)
  1267.       (and (setq gf (and (or errorp (gboundp gf-spec))
  1268.                  (gdefinition gf-spec)))
  1269.            (let ((nreq (compute-discriminating-function-arglist-info gf)))
  1270.          (setq specls (append (parse-specializers specls)
  1271.                       (make-list (- nreq (length specls))
  1272.                          :initial-element
  1273.                          *the-class-t*)))
  1274.          (and 
  1275.            (setq method (get-method gf quals specls errorp))
  1276.            (setq name
  1277.              (intern-function-name (make-method-spec gf-spec
  1278.                                  quals
  1279.                                  specls))))))))
  1280.     (values gf method name)))
  1281.  
  1282.  
  1283.  
  1284. (defun specialized-lambda-list-parameters (specialized-lambda-list)
  1285.   (multiple-value-bind (parameters ignore1 ignore2)
  1286.       (parse-specialized-lambda-list specialized-lambda-list)
  1287.     (declare (ignore ignore1 ignore2))
  1288.     parameters))
  1289.  
  1290. (defun specialized-lambda-list-lambda-list (specialized-lambda-list)
  1291.   (multiple-value-bind (ignore1 lambda-list ignore2)
  1292.       (parse-specialized-lambda-list specialized-lambda-list)
  1293.     (declare (ignore ignore1 ignore2))
  1294.     lambda-list))
  1295.  
  1296. (defun specialized-lambda-list-specializers (specialized-lambda-list)
  1297.   (multiple-value-bind (ignore1 ignore2 specializers)
  1298.       (parse-specialized-lambda-list specialized-lambda-list)
  1299.     (declare (ignore ignore1 ignore2))
  1300.     specializers))
  1301.  
  1302. (defun specialized-lambda-list-required-parameters (specialized-lambda-list)
  1303.   (multiple-value-bind (ignore1 ignore2 ignore3 required-parameters)
  1304.       (parse-specialized-lambda-list specialized-lambda-list)
  1305.     (declare (ignore ignore1 ignore2 ignore3))
  1306.     required-parameters))
  1307.  
  1308. (defun parse-specialized-lambda-list (arglist &optional post-keyword)
  1309.   (declare (values parameters lambda-list specializers required-parameters))
  1310.   (let ((arg (car arglist)))
  1311.     (cond ((null arglist) (values nil nil nil nil))
  1312.       ((eq arg '&aux)
  1313.        (values nil arglist nil))
  1314.       ((memq arg lambda-list-keywords)
  1315.        (unless (memq arg '(&optional &rest &key &allow-other-keys &aux))
  1316.          ;; Warn about non-standard lambda-list-keywords, but then
  1317.          ;; go on to treat them like a standard lambda-list-keyword
  1318.          ;; what with the warning its probably ok.
  1319.          (warn "Unrecognized lambda-list keyword ~S in arglist.~%~
  1320.                     Assuming that the symbols following it are parameters,~%~
  1321.                     and not allowing any parameter specializers to follow~%~
  1322.                     to follow it."
  1323.            arg))
  1324.        ;; When we are at a lambda-list-keyword, the parameters don't
  1325.        ;; include the lambda-list-keyword; the lambda-list does include
  1326.        ;; the lambda-list-keyword; and no specializers are allowed to
  1327.        ;; follow the lambda-list-keywords (at least for now).
  1328.        (multiple-value-bind (parameters lambda-list)
  1329.            (parse-specialized-lambda-list (cdr arglist) t)
  1330.          (values parameters
  1331.              (cons arg lambda-list)
  1332.              ()
  1333.              ())))
  1334.       (post-keyword
  1335.        ;; After a lambda-list-keyword there can be no specializers.
  1336.        (multiple-value-bind (parameters lambda-list)
  1337.            (parse-specialized-lambda-list (cdr arglist) t)           
  1338.          (values (cons (if (listp arg) (car arg) arg) parameters)
  1339.              (cons arg lambda-list)
  1340.              ()
  1341.              ())))
  1342.       (t
  1343.        (multiple-value-bind (parameters lambda-list specializers required)
  1344.            (parse-specialized-lambda-list (cdr arglist))
  1345.          (values (cons (if (listp arg) (car arg) arg) parameters)
  1346.              (cons (if (listp arg) (car arg) arg) lambda-list)
  1347.              (cons (if (listp arg) (cadr arg) 't) specializers)
  1348.              (cons (if (listp arg) (car arg) arg) required)))))))
  1349.  
  1350.  
  1351. (eval-when (load eval)
  1352.   (setq *boot-state* 'early))
  1353.  
  1354.  
  1355.  
  1356. (defmacro with-slots
  1357.       (slots instance &body body &environment env)
  1358.   (let ((gensym (gensym))
  1359.     (specs (mapcar #'(lambda (ss)
  1360.                (if (consp ss)
  1361.                    (list (car ss)
  1362.                      (variable-lexical-p (car ss) env)
  1363.                      (cadr ss))
  1364.                    (list ss (variable-lexical-p ss env) ss)))
  1365.                slots)))
  1366.     (expand-with-slots specs
  1367.                body
  1368.                env
  1369.                gensym
  1370.                instance
  1371.                #'(lambda (s) `(slot-value ,gensym ',s)))))
  1372.  
  1373. (defmacro with-accessors
  1374.       (slot-accessor-pairs instance &body body &environment env)
  1375.   (let ((gensym (gensym))
  1376.     (specs (mapcar #'(lambda (ss)
  1377.                (list (car ss)
  1378.                  (variable-lexical-p (car ss) env)
  1379.                  (cadr ss)))
  1380.                slot-accessor-pairs)))    
  1381.     (expand-with-slots specs
  1382.                body
  1383.                env
  1384.                gensym
  1385.                instance
  1386.                #'(lambda (a) `(,a ,gensym)))))
  1387.  
  1388. (defun expand-with-slots (specs body env gensym instance translate-fn)
  1389.   `(let ((,gensym ,instance))
  1390.      ,@(and (symbolp instance)
  1391.         `((declare (variable-rebinding ,gensym ,instance))))
  1392.      ,gensym
  1393.      ,@(cdr (walk-form `(progn ,@body)
  1394.                env
  1395.                #'(lambda (f c e)
  1396.                (expand-with-slots-internal specs
  1397.                                f
  1398.                                c
  1399.                                translate-fn
  1400.                                e))))))
  1401.  
  1402. (defun expand-with-slots-internal (specs form context translate-fn env)
  1403.   (let ((entry nil))
  1404.     (cond ((not (eq context :eval)) form)
  1405.       ((symbolp form)
  1406.        (if (and (setq entry (assoc form specs))
  1407.             (eq (cadr entry) (variable-lexical-p form env)))
  1408.            (funcall translate-fn (caddr entry))
  1409.            form))
  1410.       ((not (listp form)) form)
  1411.       ((member (car form) '(setq setf))
  1412.        ;; Have to be careful.  We must only convert the form to a SETF
  1413.        ;; form when we convert one of the 'logical' variables to a form
  1414.        ;; Otherwise we will get looping in implementations where setf
  1415.        ;; is a macro which expands into setq.
  1416.        (let ((kind (car form)))
  1417.          (labels ((scan-setf (tail)
  1418.             (if (null tail)
  1419.                 nil
  1420.                 (walker::relist*
  1421.                   tail
  1422.                   (if (and (setq entry (assoc (car tail) specs))
  1423.                        (eq (cadr entry)
  1424.                        (variable-lexical-p (car tail)
  1425.                                    env)))
  1426.                   (progn (setq kind 'setf)
  1427.                      (funcall translate-fn (caddr entry)))
  1428.                   (car tail))
  1429.                   (cadr tail)
  1430.                   (scan-setf (cddr tail))))))
  1431.            (let (new-tail)
  1432.          (setq new-tail (scan-setf (cdr form)))
  1433.          (walker::recons form kind new-tail)))))
  1434.       ((eq (car form) 'multiple-value-setq)
  1435.        (let* ((vars (cadr form))
  1436.           (gensyms (mapcar #'(lambda (i) (declare (ignore i)) (gensym))
  1437.                    vars)))
  1438.          `(multiple-value-bind ,gensyms 
  1439.           ,(caddr form)
  1440.         .,(reverse (mapcar #'(lambda (v g) `(setf ,v ,g))
  1441.                    vars
  1442.                    gensyms)))))
  1443.       (t form))))
  1444.  
  1445.